module Control.Monad.Error.Map
( MonadMapError (..)
, (?=>>)
, (?>>)
, option''
, many''
, many1''
, manyTill''
, sepBy''
, sepBy1''
, skipMany''
, skipMany1''
) where
import Prelude hiding (head, tail, init, last, minimum)
import Control.Monad
import Control.Monad.Error.Class
import Control.Monad.Trans.Except
import Data.Conduit
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe
import Data.Void
class (MonadError e m_e, MonadError e' m_e') => MonadMapError e m_e e' m_e' | m_e -> e, m_e' -> e', m_e e' -> m_e', m_e' e -> m_e where
mapError :: (e -> e') -> m_e a -> m_e' a
instance MonadMapError e (Either e) e' (Either e') where
mapError f = either (Left . f) Right
{-# INLINE mapError #-}
instance Monad m => MonadMapError e (ExceptT e m) e' (ExceptT e' m) where
mapError f = ExceptT . (mapError f <$>) . runExceptT
{-# INLINE mapError #-}
instance MonadMapError e m_e e' m_e' => MonadMapError e (ConduitT i o m_e) e' (ConduitT i o m_e') where
mapError f = transPipe (mapError f)
{-# INLINE mapError #-}
infixl 1 ?=>>
(?=>>) ::
( MonadMapError e m_e (Either e e') m_Either_e_e'
, MonadMapError Void m_Void (Either e e') m_Either_e_e'
, MonadMapError (Either e e') m_Either_e_e' e' m_e'
) => m_e a -> (e -> m_Void e') -> m_e' a
(?=>>) action mapper =
mapError (either (error "?=>>") id)
$ catchError (mapError Left action)
$ ((throwError . Right) =<<) . mapError absurd . mapper . either id (error "?=>>")
{-# INLINE (?=>>) #-}
infixl 1 ?>>
(?>>) ::
( MonadMapError () m_Unit (Maybe e) m_Maybe_e
, MonadMapError Void m_Void (Maybe e) m_Maybe_e
, MonadMapError (Maybe e) m_Maybe_e e m_e
) => m_Unit a -> m_Void e -> m_e a
(?>>) action mapper =
mapError (fromMaybe (error "?>>"))
$ catchError (mapError (const Nothing) action)
$ const $ (throwError . Just) =<< mapError absurd mapper
{-# INLINE (?>>) #-}
option'' ::
( MonadPlus m_Unit
, MonadMapError e m_e () m_Unit
, MonadMapError () m_Unit e' m_e'
) => m_e a -> m_e' (Maybe a)
option'' !x = mapError (error "Control.Monad.Error.Map.option''") $ mapError (const ()) (Just <$> x) `mplus` return Nothing
{-# INLINE option'' #-}
many'' ::
( MonadPlus m_Unit
, MonadMapError e m_e () m_Unit
, MonadMapError () m_Unit e' m_e'
) => m_e a -> m_e' [a]
many'' !x =
reverse <$> go []
where
go !r = do
!n <- option'' x
case n of
Nothing -> return r
Just !c -> go (c : r)
{-# INLINE many'' #-}
many1'' ::
( MonadPlus m_Unit
, MonadMapError e m_e () m_Unit
, MonadMapError () m_Unit e m_e
) => m_e a -> m_e (NonEmpty a)
many1'' !x = do
!h <- x
!t <- many'' x
return $ h :| t
{-# INLINE many1'' #-}
manyTill'' ::
( MonadPlus m_Unit
, MonadMapError e' m_e' () m_Unit
, MonadMapError () m_Unit e m_e
) => m_e a -> m_e' b -> m_e [a]
manyTill'' !x !end =
reverse <$> go []
where
go !r = do
!n <- option'' end
case n of
Just _ -> return r
Nothing -> do
!c <- x
go (c : r)
{-# INLINE manyTill'' #-}
sepBy'' ::
( MonadPlus m_Unit
, MonadMapError e m_e () m_Unit
, MonadMapError () m_Unit e'' m_e''
, MonadMapError e' m_e' () m_Unit
, MonadMapError () m_Unit () m_Unit
) => m_e a -> m_e' s -> m_e'' [a]
sepBy'' !x !sep = do
!h <- option'' x
case h of
Nothing -> return []
Just c -> do
!t <- many'' (mapError (const ()) sep >> mapError (const ()) x)
return $ c : t
{-# INLINE sepBy'' #-}
sepBy1'' ::
( MonadPlus m_Unit
, MonadMapError e m_e () m_Unit
, MonadMapError () m_Unit e m_e
, MonadMapError e' m_e' () m_Unit
, MonadMapError () m_Unit () m_Unit
) => m_e a -> m_e' s -> m_e (NonEmpty a)
sepBy1'' !x !sep = do
!h <- x
!t <- many'' (mapError (const ()) sep >> mapError (const ()) x)
return $ h :| t
{-# INLINE sepBy1'' #-}
skipMany'' ::
( MonadPlus m_Unit
, MonadMapError e m_e () m_Unit
, MonadMapError () m_Unit e' m_e'
) => m_e a -> m_e' ()
skipMany'' !x =
go
where
go = do
n <- option'' x
case n of
Nothing -> return ()
Just _ -> go
{-# INLINE skipMany'' #-}
skipMany1'' ::
( MonadPlus m_Unit
, MonadMapError e m_e () m_Unit
, MonadMapError () m_Unit e m_e
) => m_e a -> m_e ()
skipMany1'' !x = x >> skipMany'' x
{-# INLINE skipMany1'' #-}