never executed always true always false

    1 module HelVM.HelIO.Control.Safe (
    2   safeIOToPTextIO,
    3 
    4   safeIOToIO,
    5   safeToIO,
    6   safeTToIO,
    7   runSafeT,
    8   runSafe,
    9 
   10   safeToText,
   11   safeToEitherLegacy,
   12 
   13   orErrorTuple,
   14   orError,
   15   unsafe,
   16 
   17   nonEmptyFromList,
   18   maybeOrError,
   19   maybeToSafe,
   20   safeT,
   21 
   22   liftExceptT,
   23   liftSafe,
   24   liftEitherError,
   25   liftEitherLegacy,
   26 
   27   liftMaybeOrErrorTupleList,
   28   liftMaybeOrErrorTuple,
   29   liftMaybeOrError,
   30 
   31   liftErrorWithTupleList,
   32   liftErrorTupleList,
   33   liftErrorWithPrefix,
   34   liftErrorTuple,
   35   liftError,
   36 
   37   appendErrorTupleList,
   38   appendErrorTuple,
   39   appendError,
   40   (<?>),
   41 
   42   MonadSafe,
   43   SafeT,
   44   EitherLegacy,
   45   EitherError,
   46   Safe,
   47 ) where
   48 
   49 import           HelVM.HelIO.Control.Message
   50 
   51 import           HelVM.HelIO.Extra
   52 
   53 import           Control.Monad.Except        hiding (ExceptT, runExceptT)
   54 
   55 import           Control.Type.Operator
   56 
   57 import           System.IO.Error
   58 
   59 import qualified Data.DList                  as D
   60 
   61 -- | DeConstructors
   62 safeIOToPTextIO :: Show a => IO (Safe a) -> IO Text
   63 safeIOToPTextIO a = showP <$> safeIOToIO a
   64 
   65 safeIOToIO :: IO (Safe a) -> IO a
   66 safeIOToIO a = safeToIO =<< a
   67 
   68 safeToIO :: Safe a -> IO a
   69 safeToIO = safeTToIO <$> liftSafe
   70 
   71 safeTToIO :: SafeT IO a -> IO a
   72 safeTToIO = liftExceptT <$> withExceptT (userError <$> errorsToString)
   73 
   74 runSafeT :: SafeT m a -> m (Safe a)
   75 runSafeT = runExceptT
   76 
   77 runSafe :: Safe a -> Safe a
   78 runSafe = id
   79 
   80 safeToText :: Safe a -> Text
   81 safeToText (Left messages) = errorsToText messages
   82 safeToText (Right       _) = ""
   83 
   84 safeToEitherLegacy :: Safe a -> EitherLegacy a
   85 safeToEitherLegacy = first errorsToString
   86 
   87 orErrorTuple :: MessageTuple -> Safe a -> a
   88 orErrorTuple t = unsafe <$> appendErrorTuple t
   89 
   90 orError :: Show e => e -> Safe a -> a
   91 orError e = unsafe <$> appendError (show e)
   92 
   93 unsafe :: Safe a -> a
   94 unsafe (Right a) = a
   95 unsafe (Left  a) = (error <$> errorsToText) a
   96 
   97 -- | Constructors
   98 
   99 nonEmptyFromList :: MonadSafe m => Text -> [a] -> m $ NonEmpty a
  100 nonEmptyFromList message = liftSafe <$> maybeToSafe message <$> nonEmpty
  101 
  102 maybeOrError :: Show e => e -> Maybe a -> Safe a
  103 maybeOrError = maybeToSafe <$> show
  104 
  105 maybeToSafe :: Message -> Maybe a -> Safe a
  106 maybeToSafe = maybeToRight <$> D.singleton
  107 
  108 safeT :: Monad m => m a -> SafeT m a
  109 safeT a = ExceptT $ pure <$> a
  110 
  111 -- | Lift
  112 liftExceptT :: MonadError e m => ExceptT e m a -> m a
  113 liftExceptT = liftEither <=< runExceptT
  114 
  115 liftSafe :: MonadSafe m => Safe a -> m a
  116 liftSafe = liftEither
  117 
  118 liftEitherError :: MonadSafe m => EitherError a -> m a
  119 liftEitherError = liftSafe <$> first D.singleton
  120 
  121 liftEitherLegacy :: MonadSafe m => EitherLegacy a -> m a
  122 liftEitherLegacy = liftSafe <$> first stringToErrors
  123 
  124 -- | Lift from Maybe
  125 liftMaybeOrErrorTupleList :: MonadSafe m => [MessageTuple] -> Maybe a -> m a
  126 liftMaybeOrErrorTupleList = liftMaybeOrError <$> tupleListToMessage
  127 
  128 liftMaybeOrErrorTuple :: MonadSafe m => MessageTuple -> Maybe a -> m a
  129 liftMaybeOrErrorTuple = liftMaybeOrError <$> tupleToMessage
  130 
  131 liftMaybeOrError :: MonadSafe m => Message -> Maybe a -> m a
  132 liftMaybeOrError e = liftSafe <$> maybeToRight (D.singleton e)
  133 
  134 -- | Lift from Message
  135 liftErrorWithTupleList :: MonadSafe m => Message -> [MessageTuple] -> m a
  136 liftErrorWithTupleList m l = liftError (m <> tupleListToMessage l)
  137 
  138 liftErrorTupleList :: MonadSafe m => [MessageTuple] -> m a
  139 liftErrorTupleList = liftError <$> tupleListToMessage
  140 
  141 liftErrorWithPrefix :: MonadSafe m => Message -> Message -> m a
  142 liftErrorWithPrefix prefix showed = liftErrorTuple (prefix , showed)
  143 
  144 liftErrorTuple :: MonadSafe m => MessageTuple -> m a
  145 liftErrorTuple = liftError <$> tupleToMessage
  146 
  147 liftError :: MonadSafe m => Message -> m a
  148 liftError = throwError <$> D.singleton
  149 
  150 -- | Append Message
  151 appendErrorTupleList :: MonadSafe m => [MessageTuple] -> m a -> m a
  152 appendErrorTupleList = appendError <$> tupleListToMessage
  153 
  154 appendErrorTuple :: MonadSafe m => MessageTuple -> m a -> m a
  155 appendErrorTuple = appendError <$> tupleToMessage
  156 
  157 appendError :: MonadSafe m => Message -> m a -> m a
  158 appendError message a = catchError a appendAndThrow where appendAndThrow es = throwError (es `D.snoc` message)
  159 
  160 infix  0 <?>
  161 (<?>) :: MonadSafe m => m a -> Message -> m a
  162 (<?>) a message = appendError message a
  163 
  164 -- | Types
  165 type MonadSafe m = MonadError Messages m
  166 
  167 type SafeT m = ExceptT Messages m
  168 
  169 type Safe = Either Messages
  170 
  171 type EitherError = Either Text
  172 
  173 type EitherLegacy = Either String