module Language.KURE.Combinators
(
MonadCatch(..)
, (<<+)
, catchesM
, tryM
, mtryM
, attemptM
, testM
, notM
, modFailMsg
, setFailMsg
, prefixFailMsg
, withPatFailMsg
, guardMsg
, guardM
, ifM
, whenM
, unlessM
, CategoryCatch(..)
, (<+)
, readerT
, acceptR
, accepterR
, tryR
, attemptR
, changedR
, repeatR
, (>+>)
, orR
, andR
, catchesT
, result
, argument
, toFst
, toSnd
, swap
, fork
, forkFirst
, forkSecond
, constant
) where
import Prelude hiding (id , (.), catch)
import Control.Monad
import Control.Category
import Control.Arrow
import Data.Monoid
import Data.List (isPrefixOf)
infixl 3 >+>, <+, <<+
class Monad m => MonadCatch m where
catchM :: m a -> (String -> m a) -> m a
(<<+) :: MonadCatch m => m a -> m a -> m a
ma <<+ mb = ma `catchM` const mb
catchesM :: MonadCatch m => [m a] -> m a
catchesM = foldr (<<+) (fail "catchesM failed")
tryM :: MonadCatch m => a -> m a -> m a
tryM a ma = ma <<+ return a
mtryM :: (MonadCatch m, Monoid a) => m a -> m a
mtryM = tryM mempty
attemptM :: MonadCatch m => m a -> m (Either String a)
attemptM ma = liftM Right ma `catchM` (return . Left)
testM :: MonadCatch m => m a -> m Bool
testM ma = liftM (const True) ma <<+ return False
notM :: MonadCatch m => m a -> m ()
notM ma = ifM (testM ma) (fail "notM of success") (return ())
modFailMsg :: MonadCatch m => (String -> String) -> m a -> m a
modFailMsg f ma = ma `catchM` (fail . f)
setFailMsg :: MonadCatch m => String -> m a -> m a
setFailMsg msg = modFailMsg (const msg)
prefixFailMsg :: MonadCatch m => String -> m a -> m a
prefixFailMsg msg = modFailMsg (msg ++)
withPatFailMsg :: MonadCatch m => String -> m a -> m a
withPatFailMsg msg = modFailMsg (\ e -> if "Pattern match failure" `isPrefixOf` e then msg else e)
guardMsg :: Monad m => Bool -> String -> m ()
guardMsg b msg = unless b (fail msg)
guardM :: Monad m => Bool -> m ()
guardM b = guardMsg b "guardM failed"
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM mb m1 m2 = do b <- mb
if b then m1 else m2
whenM :: Monad m => m Bool -> m a -> m a
whenM mb ma = ifM mb ma (fail "whenM: condition False")
unlessM :: Monad m => m Bool -> m a -> m a
unlessM mb ma = ifM mb (fail "unlessM: condition True") ma
class Category (~>) => CategoryCatch (~>) where
failT :: String -> a ~> b
catchT :: (a ~> b) -> (String -> (a ~> b)) -> (a ~> b)
(<+) :: CategoryCatch (~>) => (a ~> b) -> (a ~> b) -> (a ~> b)
f <+ g = f `catchT` \ _ -> g
readerT :: ArrowApply (~>) => (a -> (a ~> b)) -> (a ~> b)
readerT f = (f &&& id) ^>> app
acceptR :: (CategoryCatch (~>), ArrowApply (~>)) => (a -> Bool) -> String -> (a ~> a)
acceptR p msg = readerT $ \ a -> if p a then id else failT msg
accepterR :: (CategoryCatch (~>), ArrowApply (~>)) => (a ~> Bool) -> String -> (a ~> a)
accepterR t msg = forkFirst t >>> readerT (\ (b,a) -> if b then constant a else failT msg)
tryR :: CategoryCatch (~>) => (a ~> a) -> (a ~> a)
tryR r = r <+ id
attemptR :: (CategoryCatch (~>), Arrow (~>)) => (a ~> a) -> (a ~> (Bool,a))
attemptR r = (r >>^ (True,)) <+ arr (False,)
changedR :: (CategoryCatch (~>), ArrowApply (~>), Eq a) => (a ~> a) -> (a ~> a)
changedR r = readerT (\ a -> r >>> acceptR (/=a) "changedR: value is unchanged")
repeatR :: CategoryCatch (~>) => (a ~> a) -> (a ~> a)
repeatR r = r >>> tryR (repeatR r)
(>+>) :: (CategoryCatch (~>), ArrowApply (~>)) => (a ~> a) -> (a ~> a) -> (a ~> a)
r1 >+> r2 = attemptR r1 >>> readerT (\ (b,_) -> snd ^>> if b then tryR r2 else r2)
orR :: (CategoryCatch (~>), ArrowApply (~>)) => [a ~> a] -> (a ~> a)
orR = foldr (>+>) (failT "orR failed")
andR :: Category (~>) => [a ~> a] -> (a ~> a)
andR = foldr (>>>) id
catchesT :: CategoryCatch (~>) => [a ~> b] -> (a ~> b)
catchesT = foldr (<+) (failT "catchesT failed")
result :: Arrow (~>) => (b -> c) -> (a ~> b) -> (a ~> c)
result f a = a >>^ f
argument :: Arrow (~>) => (a -> b) -> (b ~> c) -> (a ~> c)
argument f a = f ^>> a
toFst :: Arrow (~>) => (a ~> b) -> ((a,x) ~> b)
toFst f = fst ^>> f
toSnd :: Arrow (~>) => (a ~> b) -> ((x,a) ~> b)
toSnd f = snd ^>> f
swap :: Arrow (~>) => ((a,b) ~> (b,a))
swap = arr (\(a,b) -> (b,a))
fork :: Arrow (~>) => (a ~> (a,a))
fork = arr (\a -> (a,a))
forkFirst :: Arrow (~>) => (a ~> b) -> (a ~> (b , a))
forkFirst sf = fork >>> first sf
forkSecond :: Arrow (~>) => (a ~> b) -> (a ~> (a , b))
forkSecond sf = fork >>> second sf
constant :: Arrow (~>) => b -> (a ~> b)
constant b = arr (const b)